home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / icon / packages.lha / packages / atari / ats.arc / TESTS.ARC / RSG.ICN < prev    next >
Text File  |  1990-03-28  |  6KB  |  278 lines
  1. global defs, ifile, in, limit, prompt, tswitch
  2.  
  3. record nonterm(name)
  4. record charset(chars)
  5. record query(name)
  6.  
  7. procedure main(args)
  8.    local line, plist, s, opts
  9.                     # procedures to try on input lines
  10.    plist := [define,generate,grammar,source,comment,prompter,error]
  11.    defs := table()            # table of definitions
  12.    defs["lb"] := [["<"]]        # built-in definitions
  13.    defs["rb"] := [[">"]]
  14.    defs["vb"] := [["|"]]
  15.    defs["nl"] := [["\n"]]
  16.    defs[""] := [[""]]
  17.    defs["&lcase"] := [[charset(&lcase)]]
  18.    defs["&ucase"] := [[charset(&ucase)]]
  19.    defs["&digit"] := [[charset(&digits)]]
  20.  
  21.    opts := getopt(args,"tl+l+")[1]
  22.    limit := \opts["l"] | 1000
  23.    tswitch := \opts["t"]
  24.    &random := \opts["s"]
  25.  
  26.    ifile := [&input]            # stack of input files
  27.    prompt := ""
  28.    while in := pop(ifile) do {        # process all files
  29.       repeat {
  30.          if *prompt ~= 0 then writes(prompt)
  31.          line := read(in) | break
  32.          while line[-1] == "\\" do line := line[1:-1] || read(in) | break
  33.          (!plist)(line)
  34.          }
  35.       close(in)
  36.       }
  37. end
  38.  
  39. #  process alternatives
  40. #
  41. procedure alts(defn)
  42.    local alist
  43.    alist := []
  44.    defn ? while put(alist,syms(tab(upto('|') | 0))) do move(1) | break
  45.    return alist
  46. end
  47.  
  48. #  look for comment
  49. #
  50. procedure comment(line)
  51.    if line[1] == "#" then return
  52. end
  53.  
  54. #  look for definition
  55. #
  56. procedure define(line)
  57.    return line ?
  58.       defs[(="<",tab(find(">::=")))] := (move(4),alts(tab(0)))
  59. end
  60.  
  61. #  define nonterminal
  62. #
  63. procedure defnon(sym)
  64.    local chars, name
  65.    if sym ? {
  66.       ="'" &
  67.       chars := cset(tab(-1)) &
  68.       ="'"
  69.       }
  70.    then return charset(chars)
  71.    else if sym ? {
  72.       ="?" &
  73.       name := tab(0)
  74.       }
  75.    then return query(name)
  76.    else return nonterm(sym)
  77. end
  78.  
  79. #  note erroneous input line
  80. #
  81. procedure error(line)
  82.    write("*** erroneous line:  ",line)
  83.    return
  84. end
  85.  
  86. #  generate sentences
  87. #
  88. procedure gener(goal)
  89.    local pending, symbol
  90.    pending := [nonterm(goal)]
  91.    while symbol := get(pending) do {
  92.       if \tswitch then
  93.          write(&errout,symimage(symbol),listimage(pending))
  94.       case type(symbol) of {
  95.          "string":   writes(symbol)
  96.          "charset":  writes(?symbol.chars)
  97.          "query":    {
  98.             writes(&errout,"*** supply string for ",symbol.name,"  ")
  99.                writes(read()) | {
  100.                write(&errout,"*** no value for query to ",symbol.name)
  101.                break
  102.                }
  103.             }
  104.          "nonterm":  {
  105.             pending := ?\defs[symbol.name] ||| pending | {
  106.                write(&errout,"*** undefined nonterminal:  <",symbol.name,">")
  107.                break 
  108.                }
  109.             if *pending > \limit then {
  110.                write(&errout,"*** excessive symbols remaining")
  111.                break 
  112.                }
  113.             }
  114.          }
  115.       }
  116.    write()
  117. end
  118.  
  119. #  look for generation specification
  120. #
  121. procedure generate(line)
  122.    local goal, count
  123.    if line ? {
  124.       ="<" &
  125.       goal := tab(upto('>')) \ 1 &
  126.       move(1) &
  127.       count := (pos(0) & 1) | integer(tab(0))
  128.       }
  129.    then {
  130.       every 1 to count do
  131.          gener(goal)
  132.       return
  133.       }
  134.    else fail
  135. end
  136.  
  137. #  get right hand side of production
  138. #
  139. procedure getrhs(a)
  140.    local rhs
  141.    rhs := ""
  142.    every rhs ||:= listimage(!a) || "|"
  143.    return rhs[1:-1]
  144. end
  145.  
  146. #  look for request to write out grammar
  147. #
  148. procedure grammar(line)
  149.    local file, out, name
  150.    if line ? {
  151.       name := tab(find("->")) &
  152.       move(2) &
  153.       file := tab(0) &
  154.       out := if *file = 0 then &output else {
  155.          open(file,"w") | {
  156.             write(&errout,"*** cannot open ",file)
  157.             fail
  158.             }
  159.          }
  160.       }
  161.    then {
  162.       (*name = 0) | (name[1] == "<" & name[-1] == ">") | fail
  163.       pwrite(name,out)
  164.       if *file ~= 0 then close(out)
  165.       return
  166.       }
  167.    else fail
  168. end
  169.  
  170. #  produce image of list of grammar symbols
  171. #
  172. procedure listimage(a)
  173.    local s, x
  174.    s := ""
  175.    every x := !a do
  176.       s ||:= symimage(x)
  177.    return s
  178. end
  179.  
  180. #  look for new prompt symbol
  181. #
  182. procedure prompter(line)
  183.    if line[1] == "=" then {
  184.       prompt := line[2:0]
  185.       return
  186.       }
  187. end
  188.  
  189. #  write out grammar
  190. #
  191. procedure pwrite(name,ofile)
  192.    local nt, a
  193.    static builtin
  194.    initial builtin := ["lb","rb","vb","nl","","&lcase","&ucase","&digit"]
  195.    if *name = 0 then {
  196.       a := sort(defs,3)
  197.       while nt := get(a) do {
  198.          if nt == !builtin then {
  199.             get(a)
  200.             next
  201.             }
  202.          write(ofile,"<",nt,">::=",getrhs(get(a)))
  203.          }
  204.       }
  205.    else write(ofile,name,"::=",getrhs(\defs[name[2:-1]])) |
  206.       write("*** undefined nonterminal:  ",name)
  207. end
  208.  
  209. #  look for file with input
  210. #
  211. procedure source(line)
  212.    local file
  213.    return line ? (="@" & push(ifile,in) & {
  214.       in := open(file := tab(0)) | {
  215.          write(&errout,"*** cannot open ",file)
  216.          fail
  217.          }
  218.       })
  219. end
  220.  
  221. #  produce string image of grammar symbol
  222. #
  223. procedure symimage(x)
  224.    return case type(x) of {
  225.       "string":   x
  226.       "nonterm":  "<" || x.name || ">"
  227.       "charset":  "<'" || x.chars || "'>"
  228.       }
  229. end
  230.  
  231. #  process the symbols in an alternative
  232. #
  233. procedure syms(alt)
  234.    local slist
  235.    static nonbrack
  236.    initial nonbrack := ~'<'
  237.    slist := []
  238.    alt ? while put(slist,tab(many(nonbrack)) |
  239.       defnon(2(="<",tab(upto('>')),move(1))))
  240.    return slist
  241. end
  242.  
  243. #  stop, noting incorrect usage
  244. #
  245. procedure Usage()
  246.    stop("usage:  [-t] [-l n] [-s n]")
  247. end
  248.  
  249. procedure getopt(arg,optstring)
  250.    local x,i,c,otab,flist,o,p
  251.    /optstring := string(&lcase ++ &ucase)
  252.    otab := table()
  253.    flist := []
  254.    while x := get(arg) do
  255.       x ? {
  256.      if ="-"  & not pos(0) then
  257.         while c := move(1) do
  258.            if i := find(c,optstring) + 1 then
  259.           otab[c] :=
  260.              if any(':+.',o := optstring[i]) then {
  261.             p := "" ~== tab(0) | get(arg) |
  262.                   stop("No parameter following ",x)
  263.             case o of {
  264.                ":": p
  265.                "+": integer(p) |
  266.                      stop("-",c," needs numeric parameter")
  267.                ".": real(p) |
  268.                      stop("-",c," needs numeric parameter")
  269.                }
  270.             }
  271.              else 1
  272.            else stop("Unrecognized option: ",x)
  273.      else put(flist,x)
  274.       }
  275.    return [otab,flist]
  276. end
  277.  
  278.